home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / copyalloc.c < prev    next >
C/C++ Source or Header  |  1992-10-06  |  18KB  |  801 lines
  1. /*    
  2.   * Allocation routines for feel
  3.   *
  4.   */
  5.  
  6. /* what we need to stay ahead*/
  7. #include "structs.h"
  8. #include "funcalls.h"
  9. #include "global.h"
  10. #include "allocate.h" 
  11. #include "error.h"
  12. #include "table.h"
  13.  
  14. /* other junk */
  15. #include "copy.h"
  16.  
  17. #ifndef DEFAULT_HEAP_SIZE
  18. #define DEFAULT_HEAP_SIZE (4*1024*1024)
  19. #endif
  20.  
  21. #ifndef DEFAULT_STACK_SPACE_SIZE
  22. #define DEFAULT_STACK_SPACE_SIZE (1*1024*1024)
  23. #endif
  24.  
  25. #define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
  26. #define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
  27.  
  28. #define ROUND_ADDR(x) x = ((((int)x)&3)==0 ? x : x+(4-((int)x&3)))
  29.  
  30. #ifdef NODEBUG
  31. #define FPRINTF_GC_BUG(x) 
  32. #define GC_BUG(x)
  33. #else
  34. #define GC_BUG(x) x
  35. #define FPRINTF_GC_BUG(x) fprintf x
  36. #endif
  37.  
  38. LispObject static_ints;
  39.  
  40. void runtime_initialise_allocator(LispObject *stacktop)
  41. {
  42.   static void initialise_stack_space(int);
  43.   extern int command_line_heap_size;
  44.   extern int command_line_stack_space_size;
  45.   extern int command_line_cons_percentage;
  46.   extern int command_line_cons_cut_off;
  47.  
  48.   int heap,stack_space;
  49.   
  50.   heap = (command_line_heap_size == 0
  51.             ? DEFAULT_HEAP_SIZE 
  52.             : command_line_heap_size);
  53.  
  54.   if (heap < 50)
  55.     heap=heap*1024*1024;
  56.  
  57.  
  58.   {
  59.     extern int command_line_cons_percentage;
  60.     extern int command_line_cons_cut_off;
  61.     
  62.     if (command_line_stack_space_size < 50)
  63.       command_line_stack_space_size = command_line_stack_space_size*1024*1024;
  64.  
  65.     stack_space = (command_line_stack_space_size == 0
  66.            ? DEFAULT_STACK_SPACE_SIZE
  67.            : command_line_stack_space_size);
  68.   }
  69.   
  70.   init_allocator(heap);
  71.   initialise_stack_space(stack_space);
  72.  
  73.   /* Really need a smarter way of doing these... --- like do them last */
  74.   add_root((LispObject *) &state_dynamic_env);
  75.   add_root(&state_last_continue);
  76.   add_root(&state_handler_stack);
  77.   add_root(&state_current_thread);
  78.   allocate_static_integers(stacktop);
  79. }
  80.  
  81. char *allocate_space(LispObject *stacktop,int n)
  82. {
  83.   return allocate_stack(stacktop,n);
  84. }
  85.  
  86. void deallocate_space(LispObject*stacktop,char *addr,int siz)
  87. {
  88.   void deallocate_stack(LispObject *, char *, int);
  89.  
  90.   deallocate_stack(stacktop,addr,siz);
  91. }
  92. void runtime_initialise_collector(LispObject *stacktop)
  93. {
  94.  
  95. }
  96.  
  97. #define NOT_YET_DONE(name) \
  98. { fprintf(stderr,"%s: cannot alloc\n",name) ; return nil;}
  99.   
  100. LispObject Fn_cons(LispObject *stacktop)
  101. {
  102.   LispObject ans;
  103.  
  104.   ans = allocate_nbytes(stacktop+2,sizeof(struct cons_structure),TYPE_CONS); 
  105.   
  106.   lval_classof(ans)=Cons;
  107.   ans->CONS.car= *stacktop;
  108.   ans->CONS.cdr= *(stacktop+1);
  109.   
  110.   return ans;
  111. }
  112.  
  113. /* Optimised to allow easier code in a lot of places... */
  114. LispObject allocate_n_conses(LispObject *stacktop, int n)
  115. {    
  116.   LispObject xx;
  117.   int i;
  118. #ifdef NOWAY  
  119.   struct cons_structure *ptr;
  120.  
  121.   xx=allocate_cbytes(stacktop,n,sizeof(struct cons_structure),TYPE_CONS);
  122.   ptr= &(xx->CONS);
  123.   lval_classof(xx)=Cons;
  124.   ptr++;
  125.   for (i=1; i<n; i++)
  126.     {
  127.       ptr->header.class=Cons; /* XXX */
  128.       ptr->car=nil;    
  129.       (ptr[-1]).cdr=(LispObject)ptr;
  130.       ptr++;
  131.     }
  132.   
  133.   ptr[-1].cdr=nil;
  134.   return xx;
  135. #else
  136.   xx=nil;
  137.   for (i=0; i<n; i++)
  138.     {
  139.       xx=EUCALL_2(Fn_cons,nil,xx);
  140.     }
  141.       
  142.   return xx;
  143.  
  144. #endif
  145. }
  146.  
  147. LispObject allocate_n_envs(LispObject *stacktop, int n)
  148. {    
  149.   LispObject xx;
  150.   int i;
  151.   xx=0;
  152.   for (i=0; i< n; i++)
  153.     {
  154.       xx=allocate_env(stacktop,nil,nil,xx);
  155.     }
  156.  
  157.   return xx;
  158. }
  159.  
  160. LispObject allocate_class(LispObject *stacktop,LispObject class)
  161. {
  162.   LispObject ans;
  163.   int i;
  164.  
  165.   STACK_TMP(class);
  166.   if (class==NULL)
  167.     ans = allocate_nbytes(stacktop,sizeof(struct class_structure),TYPE_CLASS);
  168.   else 
  169.     ans = allocate_nbytes(stacktop,
  170.               sizeof(Object_t)+sizeof(LispObject)*class->CLASS.local_count,
  171.               TYPE_CLASS);
  172.   UNSTACK_TMP(class);
  173.   lval_classof(ans) = class;
  174.  
  175.   (ans->CLASS).name = unbound;
  176.   (ans->CLASS).superclasses = nil;
  177.   (ans->CLASS).subclasses = nil;
  178.   (ans->CLASS).slot_table = nil;
  179.   (ans->CLASS).slot_list = nil;
  180.   (ans->CLASS).direct_slot_list = nil;
  181.   (ans->CLASS).precedence = nil;
  182.   (ans->CLASS).local_count = 0;
  183.   
  184.   if (class!=NULL)
  185.     {
  186.       for (i=N_SLOTS_IN_CLASS ; i<class->CLASS.local_count ; i++)
  187.     slotref(ans,i) = nil;
  188.     }
  189.   return ans;
  190. }
  191.  
  192. LispObject allocate_instance(LispObject *stacktop,LispObject class)
  193. {
  194.   LispObject ans;
  195.   int i;
  196.  
  197.   STACK_TMP(class);
  198.  
  199.   ans=allocate_nbytes(stacktop,sizeof(Object_t)
  200.               +sizeof(LispObject)*class->CLASS.local_count,TYPE_INSTANCE);
  201.   UNSTACK_TMP(class);
  202.   lval_classof(ans)=class;
  203.  
  204.   for (i=0; i<class->CLASS.local_count; i++)
  205.     slotref(ans,i)=nil;
  206.  
  207.   return ans;
  208. }
  209.  
  210. LispObject allocate_thread(LispObject *stacktop,int stack_size, 
  211.                int gc_stack_size, int nslots)
  212. { /* xxx: need extra slots hack */
  213.   LispObject ans,cont;
  214.   int extra;
  215.  
  216.   extra=nslots>0? nslots-N_SLOTS_IN_THREAD: 0;
  217.   cont=allocate_continue(stacktop);
  218.   *stacktop=cont;
  219.   
  220.   
  221.   ans=allocate_nbytes(stacktop+1,
  222.               sizeof(struct thread_structure)+extra*sizeof(LispObject),
  223.               TYPE_THREAD);
  224.   cont = *stacktop;
  225.   *stacktop=ans;
  226.   lval_classof(ans) = Thread;
  227.  
  228.   (ans->THREAD).stack_size = stack_size;
  229.   (ans->THREAD).gc_stack_size = gc_stack_size;
  230.  
  231.   (ans->THREAD).fun = nil;
  232.   (ans->THREAD).args = nil;
  233.   (ans->THREAD).value = nil;
  234.  
  235.   (ans->THREAD).status = NULL;
  236.  
  237.   (ans->THREAD).parent = nil;
  238.   (ans->THREAD).cochain = nil;
  239.   
  240.   (ans->THREAD).state = cont;
  241.   (ans->THREAD).stack_base = NULL;
  242.   (ans->THREAD).gc_stack_base = NULL;
  243.  
  244.   ans->THREAD.state->CONTINUE.thread=ans;
  245.  
  246. #ifdef MACHINE_ANY
  247.  
  248.   (ans->THREAD).stack_base = (int *) allocate_stack(stacktop+1,stack_size);
  249.   (ans->THREAD.state)->CONTINUE.gc_stack_pointer =
  250.     (ans->THREAD).gc_stack_base =
  251.       (LispObject *) allocate_stack(stacktop+1,gc_stack_size*sizeof(LispObject));
  252.   
  253.   fprintf(stderr,"{New stack: 0x%x->0x%x}", (ans->THREAD).gc_stack_base,
  254.        (ans->THREAD).gc_stack_base+gc_stack_size);
  255.   STACK_TMP(ans);
  256.   cont=EUCALL_2(Fn_cons,function_default_handler,nil);
  257.   UNSTACK_TMP(ans);
  258.   ans->THREAD.state->CONTINUE.handler_stack = cont;
  259.     
  260. #else
  261.  
  262.   ans->THREAD.stack_base = NULL;
  263.   ans->THREAD.gc_stack_base = NULL;
  264.   ans->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  265.   ans->THREAD.state->CONTINUE.handler_stack =
  266.        EUCALL_2(Fn_cons,function_default_handler,nil);
  267.  
  268. #endif
  269.   { /* ugh */
  270.     int i;
  271.     if (extra>0)
  272.       for(i=N_SLOTS_IN_THREAD; i<nslots; i++)
  273.     slotref(ans,i) = unbound;
  274.   }
  275.   return ans;
  276. }
  277.  
  278. LispObject allocate_vector(LispObject *stacktop,int size)
  279. {
  280.   LispObject ans;
  281.   int i;
  282.  
  283.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+size*sizeof(LispObject),
  284.             TYPE_VECTOR);
  285.   
  286.   lval_classof(ans)= Vector;
  287.   
  288.   ans->VECTOR.length=size;
  289.  
  290.   for(i=0; i<size ; i++)
  291.     vref(ans,i)=nil;
  292.  
  293.   return ans;
  294. }
  295.  
  296. LispObject allocate_string(LispObject *stacktop, char *string, int len)
  297. {
  298.   LispObject ans;
  299.  
  300.   len++;
  301.   ROUND_ADDR(len);
  302.   ans = allocate_nbytes(stacktop,sizeof(Object_t)+sizeof(int)+len,
  303.             TYPE_STRING); 
  304.   
  305.   lval_classof(ans)=String;
  306.   ans->STRING.length= len+1;
  307.   stringof(ans)[len]=0;
  308.   strncpy(stringof(ans),string,len);
  309.  
  310.   return ans;
  311. }
  312.  
  313. LispObject allocate_symbol(LispObject *stacktop, char *str)
  314. {
  315.   int hash(char *); /* from tables.c */
  316.  
  317.   LispObject ans;
  318.   
  319.   ans=allocate_nbytes(stacktop,sizeof(struct symbol_structure),TYPE_SYMBOL);
  320.   
  321.   lval_classof(ans)=Symbol;
  322.   (ans->SYMBOL).pname = str;
  323.   (ans->SYMBOL).lvalue = nil;
  324.   (ans->SYMBOL).lmodule = nil;
  325.   (ans->SYMBOL).gvalue = NULL;
  326.   (ans->SYMBOL).left = NULL;
  327.   (ans->SYMBOL).right = NULL;
  328.   (ans->SYMBOL).plist = nil;
  329.   (ans->SYMBOL).hash = hash(str);
  330.   
  331.   return ans;
  332. }
  333.  
  334. LispObject allocate_table(LispObject *stacktop, LispObject (*comp)(LispObject*))
  335. {
  336.   LispObject ans;
  337.  
  338.   ans=allocate_nbytes(stacktop,sizeof(struct table_structure),TYPE_TABLE);
  339.   
  340.   lval_classof(ans)=Table;
  341.   (ans->TABLE).comparator = comp;
  342.   (ans->TABLE).lisp_comparator = nil;
  343.   (ans->TABLE).tree = nil;
  344.  
  345.   return ans;
  346. }
  347.  
  348. LispObject allocate_module_function(LispObject *stacktop,
  349.                     LispObject mod,LispObject name,
  350.                     LispObject (*fun)(LispObject*),
  351.                     int code)
  352. {
  353.   LispObject ans;
  354.  
  355.   STACK_TMP(name); STACK_TMP(mod);
  356.   ans=allocate_nbytes(stacktop,sizeof(struct c_function_structure),TYPE_C_FUNCTION);
  357.   UNSTACK_TMP(mod); UNSTACK_TMP(name);
  358.   lval_classof(ans) = Function;
  359.  
  360.   ans->C_FUNCTION.name = name;
  361.   ans->C_FUNCTION.home = mod;
  362.   ans->C_FUNCTION.argtype = code;
  363.   ans->C_FUNCTION.env = NULL;
  364.  
  365.   ans->C_FUNCTION.func = fun;
  366.   
  367.   return ans;
  368. }
  369.  
  370. #ifdef NOLOWTAGINTS
  371. LispObject real_allocate_integer(LispObject *stacktop, int n)
  372. {
  373.   LispObject ans;
  374.  
  375.   if (n>=0 && n<STATIC_INTEGERS)
  376.     return vref(static_ints,n);
  377.  
  378.   ans=allocate_nbytes(stacktop,sizeof(struct integer_structure),TYPE_INT);
  379.  
  380.   lval_classof(ans)=Integer;
  381.   intval(ans)=n;
  382.  
  383.   return ans;
  384. }
  385. #endif
  386.  
  387. LispObject allocate_ratio(LispObject *stacktop,LispObject m,LispObject n)
  388. {
  389.   NOT_YET_DONE("ratio");
  390. }
  391.  
  392. LispObject allocate_float(LispObject *stacktop,double x)
  393. {
  394.   LispObject ans;
  395.  
  396.   ans=allocate_nbytes(stacktop,sizeof(struct float_structure),TYPE_FLOAT);
  397.  
  398.   lval_classof(ans)=Real;
  399.   ans->FLOAT.fvalue=x;
  400.   
  401.   return ans;
  402.   
  403. }
  404.  
  405. LispObject allocate_complex(LispObject *stacktop, LispObject x, LispObject y)
  406. {
  407.   NOT_YET_DONE("complex");
  408. }
  409.  
  410. LispObject allocate_weak_wrapper(LispObject *stacktop)
  411. {
  412.   NOT_YET_DONE("weak wrapper");
  413. }
  414.  
  415. LispObject allocate_char(LispObject *stacktop, char x)
  416. {
  417.   LispObject ans;
  418.  
  419.   ans=allocate_nbytes(stacktop,sizeof(struct character_structure),
  420.               TYPE_CHAR);
  421.   lval_classof(ans)=Character;
  422.   ans->CHAR.font=0;
  423.   ans->CHAR.code=x;
  424.   return ans;
  425.   
  426. }
  427.  
  428. LispObject allocate_continue(LispObject *stacktop)
  429. {
  430.  
  431.   LispObject ans;
  432.  
  433.   ans=allocate_nbytes(stacktop,sizeof(struct continue_structure),TYPE_CONTINUE);
  434.  
  435.   lval_classof(ans) = Continue;
  436.  
  437.   (ans->CONTINUE).thread = nil;
  438.  
  439.   (ans->CONTINUE).value = nil;
  440.   (ans->CONTINUE).target = nil;
  441.  
  442.   /*  (ans->CONTINUE).machine_state; */
  443.   (ans->CONTINUE).gc_stack_pointer = NULL;
  444.   (ans->CONTINUE).dynamic_env = NULL;
  445.   (ans->CONTINUE).last_continue = nil;
  446.   (ans->CONTINUE).handler_stack = nil;
  447.  
  448.   (ans->CONTINUE).dp = nil;
  449.  
  450.   (ans->CONTINUE).live = FALSE;
  451.   (ans->CONTINUE).unwind = FALSE;  
  452.   
  453.   return ans;
  454. }
  455.  
  456. LispObject allocate_stream(LispObject *stacktop, FILE *file, int mod)
  457. {
  458.   LispObject ans;
  459.  
  460.   ans = allocate_nbytes(stacktop,sizeof(struct stream_structure),TYPE_STREAM);
  461.  
  462.   lval_classof(ans) = Object;
  463.   (ans->STREAM).handle = file;
  464.   (ans->STREAM).name = nil; /* Wah? */
  465.   (ans->STREAM).mode = mod;
  466.   (ans->STREAM).curchar = 0;
  467.   return ans;
  468.  
  469. }
  470.  
  471. LispObject allocate_env(LispObject *stacktop, LispObject name, 
  472.             LispObject value, LispObject prev)
  473. {
  474.   LispObject ans;
  475.  
  476.   STACK_TMP(prev); STACK_TMP(name); STACK_TMP(value);
  477.   ans=allocate_nbytes(stacktop,sizeof(struct envobject),TYPE_ENV);
  478.   UNSTACK_TMP(value); UNSTACK_TMP(name); UNSTACK_TMP(prev);
  479.   lval_classof(ans) = nil; /* ? */
  480.  
  481.   ans->ENV.variable = name;
  482.   ans->ENV.value = value;
  483.   ans->ENV.next = &prev->ENV;
  484.   ans->ENV.mutable = lisptrue;
  485.  
  486.   return ans;
  487. }
  488.  
  489. LispObject allocate_envimut(LispObject *stacktop, LispObject name, LispObject value, LispObject prev)
  490. {
  491.   LispObject ans;
  492.   
  493.   ans=allocate_env(stacktop,name,value,prev);
  494.   
  495.   ans->ENV.mutable = nil;
  496.   return ans;
  497. }
  498.  
  499. LispObject allocate_special(LispObject *stacktop, 
  500.                 LispObject name, 
  501.                 LispObject (*fn)(LispObject *))
  502. {
  503.   LispObject ans;
  504.  
  505.   STACK_TMP(name);
  506.   ans=allocate_nbytes(stacktop,sizeof(struct special_structure),TYPE_SPECIAL);
  507.   UNSTACK_TMP(name);
  508.  
  509.   lval_classof(ans) = Object;
  510.  
  511.   ans->SPECIAL.name  = name;
  512.   ans->SPECIAL.env   = NULL;
  513.   ans->SPECIAL.func  = fn;
  514.  
  515.   return(ans);
  516.  
  517. }
  518.  
  519.  
  520. LispObject allocate_i_function(LispObject *stacktop, LispObject mod, 
  521.                    LispObject env, int argcode)
  522. {
  523.   LispObject ans;
  524.  
  525.   STACK_TMP(mod); STACK_TMP(env);
  526.   ans=allocate_nbytes(stacktop,sizeof(struct i_function_structure),TYPE_I_FUNCTION);
  527.  
  528.   UNSTACK_TMP(env); UNSTACK_TMP(mod);
  529.   lval_classof(ans)=Function;
  530.   ans->I_FUNCTION.name=nil;
  531.   ans->I_FUNCTION.home = mod;
  532.   ans->I_FUNCTION.env = &env->ENV;
  533.   ans->I_FUNCTION.argtype = argcode;
  534.   
  535.   ans->I_FUNCTION.bvl = nil;
  536.   ans->I_FUNCTION.body = nil;
  537.  
  538.   return ans;
  539. }
  540.  
  541.  
  542. LispObject allocate_i_module(LispObject *stacktop, LispObject name)
  543. {
  544.   LispObject ans;
  545.   LispObject tmp1,tmp2;
  546.   
  547.   STACK_TMP(name);
  548.   tmp1 = (LispObject) allocate_table(stacktop, Fn_eq);
  549.   STACK_TMP(tmp1);
  550.   tmp2 = (LispObject) allocate_table(stacktop, Fn_eq);    
  551.   STACK_TMP(tmp2);
  552.   ans=allocate_nbytes(stacktop,sizeof(struct i_module_structure), TYPE_I_MODULE);
  553.   UNSTACK_TMP(tmp2);
  554.   UNSTACK_TMP(tmp1);
  555.   UNSTACK_TMP(name);
  556.   lval_classof(ans)=Object;
  557.   ans->I_MODULE.name = name;
  558.   ans->I_MODULE.home = nil;
  559.   ans->I_MODULE.exported_names = nil;
  560.   ans->I_MODULE.bounce_flag = FALSE;
  561.   ans->I_MODULE.imported_modules = nil; /* HACK !!! GC */
  562.   ans->I_MODULE.bindings = tmp2;
  563.   
  564.   return ans;
  565. }
  566. #if 0
  567. LispObject allocate_listener(LispObject *stacktop)
  568. {
  569.   LispObject ans;
  570.  
  571.   ans=allocate_nbytes(stacktop,sizeof(struct listener_structure), TYPE_LISTENER);
  572.   lval_classof(ans)=nil; /* will be set later */
  573.   return ans;
  574. }
  575.  
  576. LispObject allocate_socket(LispObject *stacktop)
  577. {
  578.   LispObject ans;
  579.   
  580.   ans=allocate_nbytes(stacktop,sizeof(struct socket_structure), TYPE_SOCKET);
  581.   lval_classof(ans)=nil; /* will be set later */
  582.   return ans;
  583. }
  584. #endif
  585.  
  586. LispObject allocate_semaphore(LispObject *stacktop)
  587. {
  588.   LispObject ans;
  589.   
  590.   ans=allocate_nbytes(stacktop,sizeof(struct semaphore_structure), TYPE_SEMAPHORE);
  591.  
  592.   lval_classof(ans)=Object; /* Ugh */
  593.   system_allocate_semaphore(&(ans->SEMAPHORE.semaphore));
  594.  
  595.   return ans;
  596. }
  597.  
  598. LispObject allocate_c_object(LispObject *stacktop, int nslots, int width)
  599. {
  600.   NOT_YET_DONE("c-object");
  601. }
  602.  
  603. void deallocate_page(LispObject *stacktop, char *addr, int n)
  604. {
  605.   
  606. }
  607.  
  608. LispObject show_free_heap(LispObject *stacktop)
  609. {
  610.  
  611. }
  612.  
  613. LispObject show_free_space(LispObject *stacktop)
  614. {
  615.  
  616. }
  617.  
  618. void promote_free_space(LispObject *stacktop)
  619. {
  620.  
  621. }
  622.  
  623.  
  624. void allocate_static_integers(LispObject *stacktop)
  625. {
  626. #ifdef NOLOWTAGINTS
  627.   int i;
  628.  
  629.   static_ints=allocate_vector(stacktop,STATIC_INTEGERS);
  630.   for (i=0; i<STATIC_INTEGERS; i++)
  631.     {        /* alloc a big integer, then 'fix' it */
  632.       LispObject xx=real_allocate_integer(stacktop,STATIC_INTEGERS);
  633.       intval(xx)=i;
  634.       vref(static_ints,i)=xx;
  635.     }
  636.  
  637.   add_root(&static_ints);
  638. #endif
  639. }
  640.  
  641.  
  642. typedef struct free_list_struct
  643. {
  644.   int size;
  645.   struct free_list_struct *next;
  646. } *FreeList;
  647.  
  648. static SYSTEM_GLOBAL(FreeList, stack_chain);
  649.  
  650. static int free_count;
  651. static int nfrags;
  652.  
  653. void initialise_stack_space(int stackspace)
  654. {
  655.   char *space=system_malloc(stackspace);
  656.   
  657.   SYSTEM_INITIALISE_GLOBAL(FreeList,stack_chain,NULL);
  658.   SYSTEM_GLOBAL_VALUE(stack_chain) = (FreeList) space;
  659.   
  660.   SYSTEM_GLOBAL_VALUE(stack_chain)->size= stackspace - sizeof(*SYSTEM_GLOBAL_VALUE(stack_chain));
  661.   SYSTEM_GLOBAL_VALUE(stack_chain)->next= NULL;
  662.   free_count=SYSTEM_GLOBAL_VALUE(stack_chain)->size;
  663.   nfrags=1;
  664. }
  665.  
  666. void show_stack_space()
  667. {
  668.   fprintf(stderr,"Stack space: %d remaining, %d fragments\n",free_count, nfrags);
  669. }
  670. /* use header as pointer to prevously allocated stack */
  671. char* allocate_stack(LispObject *stacktop, int nbytes)
  672. {
  673.   FreeList oldstack;
  674.   FreeList *walker;
  675.   char *ret;
  676.  
  677.   if (nbytes==0)
  678.     return NULL;
  679.  
  680.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  681.   walker= &SYSTEM_GLOBAL_VALUE(stack_chain);
  682.   ROUND_ADDR(nbytes);
  683.  
  684.   free_count -= nbytes;
  685.  
  686.   while ( (*walker)!=NULL)
  687.     {
  688.       if ((*walker)->size+sizeof(*walker)==nbytes)
  689.     { 
  690.       ret= (char*) (*walker);
  691.       *walker=(*walker)->next;
  692.       nfrags--;
  693.       FPRINTF_GC_BUG((stderr,"{Cool stack: %x->%x}",ret,ret+nbytes));
  694.       GC_BUG(memset(ret,'S',nbytes));
  695.       system_close_semaphore(&S_G_V(GC_sem)); 
  696.       return ret;
  697.     }
  698.       if ((*walker)->size<nbytes)
  699.     {
  700.       FPRINTF_GC_BUG((stderr,"[Looking at: %x->%x (%d)]",*walker,(*walker)+(*walker)->size,
  701.               (*walker)->size));      
  702.       walker = &((*walker)->next);
  703.     }
  704.       else
  705.     {
  706.       ret= ((char *)((*walker)+1))+((*walker)->size-nbytes);
  707.       (*walker)->size=(*walker)->size-nbytes;
  708.       GC_BUG(memset(ret,'S',nbytes));
  709.       FPRINTF_GC_BUG((stderr,"{Alloc stack: %x->%x}",ret,ret+nbytes));
  710.       system_close_semaphore(&S_G_V(GC_sem)); 
  711.       return ret;
  712.     }
  713.     }
  714.   fprintf(stderr,"alloc stack: stack wimped out (%d remaining --- probably)\n",free_count);
  715.   system_close_semaphore(&S_G_V(GC_sem)); 
  716.   return NULL;
  717. }
  718.  
  719. void deallocate_stack(LispObject *stacktop, char *addr,int nbytes)
  720. {
  721.   FreeList old, walker;
  722.   /* Too damm lazy */
  723.   ROUND_ADDR(nbytes);
  724.  
  725.   
  726.   system_open_semaphore(stacktop,&S_G_V(GC_sem)); 
  727.   walker=SYSTEM_GLOBAL_VALUE(stack_chain);
  728.   FPRINTF_GC_BUG((stderr,"{dealloc: %x->%x [%d]",addr,addr+nbytes,nbytes));
  729.   while (   ((char *)walker->next) < addr
  730.      && walker->next!=NULL)
  731.     {
  732.       /* sanity check */
  733.       if (walker >= walker->next)
  734.     { 
  735.       FPRINTF_GC_BUG((stderr,"Rats--- strange chain\n"));
  736.       system_lisp_exit(1);
  737.     }
  738.       walker=walker->next;
  739.     }
  740.   /* 3 cases --- at the start */
  741.   if ( ((char *)(walker+1)) + walker->size == addr)
  742.     {
  743.       /* side check for end */
  744.  
  745.       if (walker->next!=NULL && addr+nbytes == (char *) walker->next)
  746.     {
  747.       walker->size = walker->size+nbytes
  748.         +sizeof(*walker)
  749.           +walker->next->size;
  750.       walker->next=walker->next->next;
  751.       free_count+=nbytes+sizeof(*walker);
  752.       nfrags--;
  753.       FPRINTF_GC_BUG((stderr,"Filler}"));
  754.     }
  755.       else    
  756.     {
  757.       walker->size=walker->size+nbytes;
  758.       free_count+=nbytes;
  759.       FPRINTF_GC_BUG((stderr,"Start}"));
  760.     }
  761.       system_close_semaphore(&S_G_V(GC_sem)); 
  762.       return;
  763.     }
  764.   /* at the end */
  765.   if ( walker->next!=NULL && addr+nbytes == (char *) walker->next)
  766.     {
  767.       old=walker->next;
  768.       walker->next=(FreeList) addr;
  769.       walker->next->size=nbytes+old->size;
  770.       walker->next->next=old->next;
  771.       free_count+=nbytes;
  772.       FPRINTF_GC_BUG((stderr,"End}"));
  773.       system_close_semaphore(&S_G_V(GC_sem)); 
  774.       return;
  775.     }
  776.   /* in the middle */
  777.   old=walker->next;      
  778.   walker->next=(FreeList) addr;
  779.   walker->next->next=old;
  780.   walker->next->size=nbytes-sizeof(*walker);
  781.   nfrags++;
  782.   free_count+=nbytes-sizeof(*walker);
  783.   FPRINTF_GC_BUG((stderr,"Middle}"));
  784.   system_close_semaphore(&S_G_V(GC_sem)); 
  785. }
  786.  
  787.   
  788. int dump_obj(unsigned int *x,int s)
  789. {
  790.   int i;
  791.   
  792.   if (s>200) s=16;
  793.  
  794.   for (i=0; i<s ; i+=4)
  795.     fprintf(stderr,"0x%x: %x %x %x %x\n",
  796.         x+i,
  797.         (int)*(x+i),(int)*(x+i+1),(int)*(x+i+2),(int)*(x+i+3));
  798.     
  799. }
  800.   
  801.